##########Supplementary R Code used for the quantitative analysis of bone surface modifications from Hominin presence in Eurasia by at least 1.95 Ma by Curran et al. published in Nature Communications. Code written by Trevor Keevil and Michael Pante#################

remove(list = ls())
set.seed(1234)
library(MASS)

BSM.data.sect # Dataset containing all Experimental BSM measurements
  kfold.BSM.data <- BSM.data.sect
  leaveoneout.BSM.data <- BSM.data.sect
  experi.BSM.data <-BSM.data.sect

arch.data # Dataset containing all Archaeological BSM measurements
 
################################
### K-FOLD CROSS VALIDATION ###
################################

# K number of folds to perform

  num.k.fold <- 10

# Randomly reorder BSM Data

  kfold.length <- rep(1:length(kfold.BSM.data[,1]))
  kfold.rand.order <- sample(kfold.length)
  reordered.BSM.data <- matrix("NA", nrow = 0, ncol = length(kfold.BSM.data[1,]))

  i<- 1
  for(i in 1:length(kfold.rand.order)){
    reordered.BSM.data <- rbind(reordered.BSM.data, kfold.BSM.data[(kfold.rand.order[i]),])
  }

# Create K groups of equal sizes (if possible)

  group.size <- ceiling(length(kfold.rand.order)/num.k.fold)
  group.size.kfold <- rep(group.size, num.k.fold)

  # If number of data points are not evenly divisible into k groups -- below code will create group sizes as evenly as possible
    # Because there are 898 observations and 10 groups -- this will create 8 groups of 90 observations and 2 groups of 89 observations

      if(sum(group.size.kfold) > length(kfold.rand.order)){
        x <- sum(group.size.kfold) - length(kfold.rand.order)
        x2 <- rep(((num.k.fold)-(x-1)):(num.k.fold))
        group.size.kfold[x2] <- (group.size - 1)
      }

  # Section the randomly ordered data points into K number of groups based on group size

    i <- 1
    for(i in 1:num.k.fold){

      # Create groups that are of size (Rounded up - Datapoints/K)
        # For this dataset groups that are of size 90

          if(group.size.kfold[i] == group.size.kfold[1]){
            group.start <-((i-1)*group.size.kfold[i])+1
            group.end <- group.start+group.size.kfold[i]-1
            group <- reordered.BSM.data[c(group.start:group.end),]

      # Create groups that are of size (Rounded down - Datapoints/K)
        # For this dataset groups that are of size 89

          }else{
            group.start <- (length(reordered.BSM.data[,1]) - (group.size.kfold[i] * (length(group.size.kfold)-(i-1))))+1
            group.end <- group.start+group.size.kfold[i]-1
            group <- reordered.BSM.data[c(group.start:group.end),]
          }

      # Label each group as kfoldgroup_# where # is a value between 1 and 10

        nam <- paste("kfoldgroup",i, sep = "_")
        assign(nam, group)
    }

# Create table to record the Box Cox transformation values for each k-fold iteration

  box.cox.per.kfold <- matrix(nrow = 0, ncol = (length(reordered.BSM.data[1,]) - 1))

# Create table to record accuracy for each k-fold iteration

  accuracy.preds.kfold <- matrix(nrow = num.k.fold, ncol = 1)

# Create array of matrices to record classification (and misclassification) rates for each BSM group in each k-fold iteration

  pred.array.kfold <- array(data = NA, dim = c(4,4,num.k.fold))

# For loop to identify QDA model accuracy of each k-fold. For each loop:
  # Separates the k number of randomly separated groups into k-1 training and 1 testing datasets of ith k fold group
  # Transform training dataset using Box Cox method
  # Transform testing dataset using Box Cox lambda values from training dataset
  # Create QDA model using training dataset
  # Classify testing dataset using training QDA model
  # Report model accuracy and BSM group misclassification rates

    i <- 1
    for(i in 1:num.k.fold){

      # Create Testing Dataset from "kfoldgroup_#" where # is the ith loop

        test.set <- get(paste("kfoldgroup",i, sep = "_"))

      # Create Training Dataset k-1 groups excluding Testing Dataset data

        train.val.num <- rep(1:num.k.fold)[-i]
        train.set <- matrix(nrow = 0, ncol = length(test.set[1,]))
        for(l in train.val.num){
          train.set <-  rbind(train.set, get(paste("kfoldgroup",l, sep = "_")))
        }

      # Record the Box Cox transformation lambda values from Training Dataset

        kfold.box.cox.lam <- matrix(NA, nrow = length(train.set[1,]), ncol = 2)

        j <- 2
        for(j in 2:length(train.set[1,])) {
          box.cox <- boxcox(train.set[,j] ~ 1, lambda = seq(-4, 4, 0.001),, plot = FALSE)
          lambda <- box.cox$x[which.max(box.cox$y)]
          kfold.box.cox.lam[j,1] <- colnames(train.set[j])
          kfold.box.cox.lam[j,2] <- lambda
        }

        kfold.box.cox.lam <- as.data.frame(kfold.box.cox.lam)
        box.cox.per.kfold <- rbind(box.cox.per.kfold, as.numeric(kfold.box.cox.lam[c(2:length(train.set)),2]))

      # Transform Training Dataset using training Box Cox lambda values

        kfold.BSM.data.sect.train <- train.set

        j <- 2
        for(j in 2:length(kfold.BSM.data.sect.train[1,])) {
          kfold.BSM.data.sect.train[,j] <- ((kfold.BSM.data.sect.train[,j]^(as.numeric(kfold.box.cox.lam [j,2])))-1)/(as.numeric(kfold.box.cox.lam [j,2]))
        }

      # Transform Testing Dataset using training Box Cox lambda values

        kfold.BSM.data.sect.test <- test.set

        j <- 2
        for(j in 2:length(kfold.BSM.data.sect.test[1,])) {
          kfold.BSM.data.sect.test[,j] <- (kfold.BSM.data.sect.test[,j]^(as.numeric(kfold.box.cox.lam [j,2]))-1)/(as.numeric(kfold.box.cox.lam [j,2]))
        }

      # Create training QDA Model from transformed Training Dataset

        kfold.qda.mod <- qda(GROUP ~., data = kfold.BSM.data.sect.train)

      # Predict Transformed Testing Dataset and obtain BSM classifications in Training QDA Model

        kfold.predicts <- predict(kfold.qda.mod, kfold.BSM.data.sect.test)
        pred.class <- kfold.predicts$class
        table <- table(kfold.BSM.data.sect.test$GROUP, pred.class)

        pred.array.kfold[,,i] <- table

      # Record prediction classification accuracy estimation for ith k-Fold in accuracy table
        
        accuracy <- mean(kfold.predicts$class == kfold.BSM.data.sect.test$GROUP)
        accuracy.preds.kfold[i,] <- accuracy
        
    }

# Mean K-fold Classification accuracy

  sum(accuracy.preds.kfold)/num.k.fold

# Confusion Matrix of K-Fold Classifications

  pred.conf.mat <- matrix(0, ncol = 4, nrow = 4)

  i <- 1
  for(i in 1:num.k.fold){
    pred.conf.mat <- (pred.conf.mat + pred.array.kfold[,,i])
  }

  row.names(pred.conf.mat) <- c("Cut", "Percussion", "Tooth", "Trample")
  colnames(pred.conf.mat) <- c("Cut", "Percussion", "Tooth", "Trample")

  pred.conf.mat

############################
### LOO CROSS VALIDATION ###
############################
  
# Number of LOO CV tests to conduct
  
  num.leaveoneout <- length(leaveoneout.BSM.data[,1])
  
# Create table to record the Box Cox transformation values for each LOO iteration
  
  box.cox.per.leaveoneout <- matrix(nrow = 0, ncol = (length(leaveoneout.BSM.data[1,]) - 1))
  
# Create table to record the classification accuracy values for each LOO iteration
  
  accuracy.preds.leaveone <- matrix(nrow = num.leaveoneout, ncol = 1)
  
# Create array of matrices to record classification (and misclassification) rates for each BSM group for each LOO iteration
  
  pred.array.leaveone <- matrix(0, nrow = 4, ncol = 4)

# For loop to identify QDA model accuracy of each LOO iteration. For each loop:
  # Separates data into training dataset of size n-1 and a testing dataset of size 1 (ith row)
  # Transform training dataset using Box Cox method
  # Transform testing dataset using Box Cox lambda values from training dataset
  # Create QDA model using training dataset
  # Classify testing dataset using training QDA model
  # Report model accuracy and BSM group misclassification rates

    i <- 1
    for(i in 1:num.leaveoneout){
    
    # Separate data into Training and Testing Datasets where Testing dataset is the ith datapoint
    
      test.set <- leaveoneout.BSM.data[i,]
      train.set <- leaveoneout.BSM.data[-i,]
    
    # Box Cox lambda values from Training dataset
    
      leavone.box.cox.lam <- matrix(NA, nrow = length(train.set[1,]), ncol = 2)
    
    # Training Dataset Box Cox lambda values
      
      j <- 2  
      for(j in 2:length(train.set[1,])) {
        box.cox <- boxcox(train.set[,j] ~ 1, lambda = seq(-4, 4, 0.001),, plot = FALSE)
        lambda <- box.cox$x[which.max(box.cox$y)]
        leavone.box.cox.lam[j,1] <- colnames(train.set[j])
        leavone.box.cox.lam[j,2] <- lambda
      } 
    
      leavone.box.cox.lam <- as.data.frame(leavone.box.cox.lam)
      box.cox.per.leaveoneout <- rbind(box.cox.per.leaveoneout, as.numeric(leavone.box.cox.lam[c(2:length(train.set)),2]))
    
    # Transform Training Dataset using Box Cox lambda values 
    
      leaveone.BSM.data.sect.train <- train.set
      j <- 2
      for(j in 2:length(leaveone.BSM.data.sect.train[1,])) {
        leaveone.BSM.data.sect.train[,j] <- ((leaveone.BSM.data.sect.train[,j]^(as.numeric(leavone.box.cox.lam [j,2])))-1)/(as.numeric(leavone.box.cox.lam [j,2]))
      }
    
    # Transforming Testing Data using Training Box Cox lambda values
    
      leaveone.BSM.data.sect.test <- test.set
      j <- 2
      for(j in 2:length(leaveone.BSM.data.sect.test[1,])) {
        leaveone.BSM.data.sect.test[,j] <- ((leaveone.BSM.data.sect.test[,j]^(as.numeric(leavone.box.cox.lam [j,2])))-1)/(as.numeric(leavone.box.cox.lam [j,2]))
      }
    
    # Training Dataset QDA model
    
      leaveone.qda.mod <- qda(GROUP ~., data = leaveone.BSM.data.sect.train)
    
    # Predict Transformed Testing Dataset and obtain BSM classifications in Training QDA Model
      
      leaveone.predicts <- predict(leaveone.qda.mod, leaveone.BSM.data.sect.test)
      pred.class <- leaveone.predicts$class
      
    # Add Testing Classification to LOO Confusion Matrix 
      
      table <- table(leaveone.BSM.data.sect.test$GROUP, pred.class)
    
      if(row.names(table) == "Cut"){
        table2 <- rbind(table, rep(0, length =4), rep(0, length =4), rep(0, length =4))
        } else if(row.names(table) == "Percussion"){
          table2 <- rbind(rep(0, length =4), table, rep(0, length =4), rep(0, length =4))
          } else if(row.names(table) == "Tooth"){
            table2 <- rbind(rep(0, length =4), rep(0, length =4), table, rep(0, length =4))
            } else if(row.names(table) == "Trample"){
              table2 <- rbind(rep(0, length =4), rep(0, length =4), rep(0, length =4), table)
              } 
    
    pred.array.leaveone <- pred.array.leaveone + table2
    
  # Record ith LOO iteration accuracy in LOO Accuracy table
    
    accuracy <- mean(leaveone.predicts$class == leaveone.BSM.data.sect.test$GROUP)
    accuracy.preds.leaveone[i,] <- accuracy
    
    print(i)
    
    }
  
# LOO Classification accuracy  
  
  mean(accuracy.preds.leaveone)

# Confusion Matrix of LOO Classifications
  
  row.names(pred.array.leaveone) <- c("Cut", "Percussion", "Tooth", "Trample")
  pred.array.leaveone
  
##########################################
### FOSSIL BSM CLASSIFICATIONS ###
##########################################
  
# Create table to record Box Cox lambda values by variable
  
  experi.box.cox.lam <- matrix(NA, nrow = length(experi.BSM.data[1,]), ncol = 2)
  
# Identify and record Box Cox lambda values
  
  j <- 2  
  for(j in 2:length(experi.BSM.data[1,])) {
    box.cox <- boxcox(experi.BSM.data[,j] ~ 1, lambda = seq(-2, 3, 0.001),, plot = FALSE)
    lambda <- box.cox$x[which.max(box.cox$y)]
    experi.box.cox.lam[j,1] <- colnames(experi.BSM.data[j])
    experi.box.cox.lam[j,2] <- lambda
  } 
  
  experi.box.cox.lam <- as.data.frame(experi.box.cox.lam)

# Transform Experimental BSM Dataset
  
  j <- 2
  for(j in 2:length(experi.BSM.data[1,])) {
    experi.BSM.data[,j] <- ((experi.BSM.data[,j]^(as.numeric(experi.box.cox.lam [j,2])))-1)/(as.numeric(experi.box.cox.lam [j,2]))
  }
  
# Transform Fossil BSM Dataset
  
  j <- 2
  for(j in 2:length(arch.data[1,])) {
    arch.data[,j] <- ((arch.data[,j]^(as.numeric(experi.box.cox.lam [j,2])))-1)/(as.numeric(experi.box.cox.lam [j,2]))
  }
  
# Create QDA Model using Experimental Data
  
  arch.qda.mod <- qda(GROUP ~., data = experi.BSM.data)
  
# Predict Fossil BSM classification using Experimental QDA model
  
  arch.predicts <- predict(arch.qda.mod, arch.data)

# Predictions as a Table
  
  data.frame(cbind(arch.data[,1], as.character(arch.predicts$class), round(arch.predicts$posterior, digits =3)))
  

